home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / num.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-28  |  27.8 KB  |  1,028 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: num.c,v 1.11 94/06/27 16:32:22 wlott Exp $
  27. *
  28. * This file implements numbers.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include <stdio.h>
  33. #include <math.h>
  34.  
  35. #include "mindy.h"
  36. #include "gc.h"
  37. #include "class.h"
  38. #include "obj.h"
  39. #include "bool.h"
  40. #include "def.h"
  41. #include "list.h"
  42. #include "type.h"
  43. #include "num.h"
  44. #include "thread.h"
  45. #include "func.h"
  46. #include "error.h"
  47. #include "print.h"
  48. #include "module.h"
  49. #include "sym.h"
  50.  
  51. obj_t obj_NumberClass = 0;
  52. obj_t obj_ComplexClass = 0;
  53. obj_t obj_RealClass = 0;
  54. obj_t obj_RationalClass = 0;
  55. obj_t obj_IntegerClass = 0;
  56. obj_t obj_FloatClass = 0;
  57. obj_t obj_SingleFloatClass = 0;
  58. obj_t obj_DoubleFloatClass = 0;
  59. obj_t obj_ExtendedFloatClass = 0;
  60.  
  61. obj_t make_single(float value)
  62. {
  63.     obj_t res = alloc(obj_SingleFloatClass, sizeof(struct single_float));
  64.  
  65.     obj_ptr(struct single_float *, res)->value = value;
  66.  
  67.     return res;
  68. }
  69.  
  70. obj_t make_double(double value)
  71. {
  72.     obj_t res = alloc(obj_DoubleFloatClass, sizeof(struct double_float));
  73.  
  74.     obj_ptr(struct double_float *, res)->value = value;
  75.  
  76.     return res;
  77. }
  78.  
  79. obj_t make_extended(long double value)
  80. {
  81.     obj_t res = alloc(obj_ExtendedFloatClass, sizeof(struct extended_float));
  82.  
  83.     obj_ptr(struct extended_float *, res)->value = value;
  84.  
  85.     return res;
  86. }
  87.  
  88. boolean idp(obj_t x, obj_t y)
  89. {
  90.     obj_t x_class, y_class;
  91.  
  92.     if (x == y)
  93.     return TRUE;
  94.     if (obj_is_fixnum(x) || obj_is_fixnum(y))
  95.     return FALSE;
  96.  
  97.     x_class = obj_ptr(struct object *, x)->class;
  98.     y_class = obj_ptr(struct object *, y)->class;
  99.  
  100.     if (x_class != y_class)
  101.     return FALSE;
  102.  
  103.     if (x_class == obj_SingleFloatClass)
  104.     return single_value(x) == single_value(y);
  105.  
  106.     if (x_class == obj_DoubleFloatClass)
  107.     return double_value(x) == double_value(y);
  108.  
  109.     if (x_class == obj_ExtendedFloatClass)
  110.     return extended_value(x) == extended_value(y);
  111.  
  112.     return FALSE;
  113. }
  114.  
  115.  
  116. /* Printer support. */
  117.  
  118. static void print_fixnum(obj_t fixnum)
  119. {
  120.     printf("%ld", fixnum_value(fixnum));
  121. }
  122.  
  123. static void print_sf(obj_t sf)
  124. {
  125.     printf("%#g", single_value(sf));
  126. }
  127.  
  128. static void change_exponent_marker(char *ptr, int marker)
  129. {
  130.     while (*ptr != '\0' && *ptr != 'e' && *ptr != 'E')
  131.     ptr++;
  132.     if (*ptr == '\0') {
  133.     ptr[0] = marker;
  134.     ptr[1] = '0';
  135.     ptr[2] = '\0';
  136.     }
  137.     else
  138.     ptr[0] = marker;
  139. }
  140.  
  141. static void print_df(obj_t df)
  142. {
  143.     char buffer[64];
  144.  
  145.     sprintf(buffer, "%#g", double_value(df));
  146.     change_exponent_marker(buffer, 'd');
  147.     printf("%s", buffer);
  148. }
  149.  
  150. static void print_xf(obj_t xf)
  151. {
  152.     char buffer[64];
  153.  
  154.     sprintf(buffer, "%#g", (double)extended_value(xf));
  155.     change_exponent_marker(buffer, 'x');
  156.     printf("%s", buffer);
  157. }
  158.  
  159.  
  160. /* Dylan routines. */
  161.  
  162. static obj_t dylan_idp(obj_t this, obj_t that)
  163. {
  164.     if (idp(this, that))
  165.     return obj_True;
  166.     else
  167.     return obj_False;
  168. }
  169.  
  170. static obj_t dylan_int_negative(obj_t x)
  171. {
  172.     return make_fixnum(-fixnum_value(x));
  173. }
  174.  
  175. static obj_t dylan_int_int_plus(obj_t x, obj_t y)
  176. {
  177.     return make_fixnum(fixnum_value(x) + fixnum_value(y));
  178. }
  179.  
  180. static obj_t dylan_int_int_minus(obj_t x, obj_t y)
  181. {
  182.     return make_fixnum(fixnum_value(x) - fixnum_value(y));
  183. }
  184.  
  185. static obj_t dylan_int_int_times(obj_t x, obj_t y)
  186. {
  187.     return make_fixnum(fixnum_value(x) * fixnum_value(y));
  188. }
  189.  
  190. static void dylan_int_int_trunc(obj_t self, struct thread *thread, obj_t *args)
  191. {
  192.     obj_t *old_sp = args - 1;
  193.     int x = fixnum_value(args[0]);
  194.     int y = fixnum_value(args[1]);
  195.  
  196.     if (y == 0)
  197.     error("Division by zero");
  198.     else {
  199.     int q = x / y;
  200.     int r = x % y;
  201.  
  202.     /* The remainder is supposed to have the same sign as the dividend. */
  203.     if (r != 0 && (r ^ x) < 0) {
  204.         r -= y;
  205.         q++;
  206.     }
  207.         
  208.     thread->sp = old_sp + 2;
  209.  
  210.     old_sp[0] = make_fixnum(q);
  211.     old_sp[1] = make_fixnum(r);
  212.     
  213.     do_return(thread, old_sp, old_sp);
  214.     }
  215. }
  216.  
  217. static void dylan_int_int_floor(obj_t self, struct thread *thread, obj_t *args)
  218. {
  219.     obj_t *old_sp = args - 1;
  220.     int x = fixnum_value(args[0]);
  221.     int y = fixnum_value(args[1]);
  222.  
  223.     if (y == 0)
  224.     error("Division by zero");
  225.     else {
  226.     int q = x / y;
  227.     int r = x % y;
  228.  
  229.     /* The remainder is supposed to be the same sign as the divisor. */
  230.     if (r != 0 && (r ^ y) < 0) {
  231.         r += y;
  232.         q--;
  233.     }
  234.  
  235.     thread->sp = old_sp + 2;
  236.  
  237.     old_sp[0] = make_fixnum(q);
  238.     old_sp[1] = make_fixnum(r);
  239.     
  240.     do_return(thread, old_sp, old_sp);
  241.     }
  242. }
  243.  
  244. static void dylan_int_int_ceil(obj_t self, struct thread *thread, obj_t *args)
  245. {
  246.     obj_t *old_sp = args - 1;
  247.     int x = fixnum_value(args[0]);
  248.     int y = fixnum_value(args[1]);
  249.  
  250.     if (y == 0)
  251.     error("Division by zero");
  252.     else {
  253.     int q = x / y;
  254.     int r = x % y;
  255.  
  256.     /* The remainder is supposed to be the opposite sign from */
  257.     /* the divisor.  */
  258.     if (r != 0 && (r ^ y) >= 0) {
  259.         r -= y;
  260.         q++;
  261.     }
  262.  
  263.     thread->sp = old_sp + 2;
  264.  
  265.     old_sp[0] = make_fixnum(q);
  266.     old_sp[1] = make_fixnum(r);
  267.     
  268.     do_return(thread, old_sp, old_sp);
  269.     }
  270. }
  271.  
  272. static void dylan_int_int_round(obj_t self, struct thread *thread, obj_t *args)
  273. {
  274.     obj_t *old_sp = args - 1;
  275.     int x = fixnum_value(args[0]);
  276.     int y = fixnum_value(args[1]);
  277.  
  278.     if (y == 0)
  279.     error("Division by zero");
  280.     else {
  281.     int q = x / y;
  282.     int r = x % y;
  283.  
  284.     if (r != 0) {
  285.         /* The remainder should be smaller (i.e. closer to zero) than */
  286.         /* half the divisor. */
  287.         if (y > 0) {
  288.         int limit = y >> 1;
  289.         if (r > limit || (r == limit && (q & 1))) {
  290.             /* r is too large. */
  291.             r -= y;
  292.             q++;
  293.         }
  294.         else if (r < -limit || (r == -limit && (q & 1))) {
  295.             /* r is too small */
  296.             r += y;
  297.             q--;
  298.         }
  299.         }
  300.         else {
  301.         int limit = -y >> 1;
  302.         if (r > limit || (r == limit && (q & 1))) {
  303.             /* r is too large. */
  304.             r += y;  /* note: y is negative. */
  305.             q--;
  306.         }
  307.         else if (r < -limit || (r == -limit && (q & 1))) {
  308.             /* r is too small */
  309.             r -= y;  /* note: y is negative. */
  310.             q++;
  311.         }
  312.         }
  313.     }
  314.  
  315.     thread->sp = old_sp + 2;
  316.  
  317.     old_sp[0] = make_fixnum(q);
  318.     old_sp[1] = make_fixnum(r);
  319.     
  320.     do_return(thread, old_sp, old_sp);
  321.     }
  322. }
  323.  
  324. static obj_t dylan_int_int_less(obj_t x, obj_t y)
  325. {
  326.     if (fixnum_value(x) < fixnum_value(y))
  327.     return obj_True;
  328.     else
  329.     return obj_False;
  330. }
  331.  
  332. static obj_t dylan_int_int_equal(obj_t x, obj_t y)
  333. {
  334.     if (fixnum_value(x) == fixnum_value(y))
  335.     return obj_True;
  336.     else
  337.     return obj_False;
  338. }
  339.  
  340. static obj_t dylan_ash(obj_t x, obj_t shift_obj)
  341. {
  342.     int shift = fixnum_value(shift_obj);
  343.  
  344.     if (shift < 0)
  345.     return make_fixnum(fixnum_value(x) >> -shift);
  346.     else
  347.     return make_fixnum(fixnum_value(x) << shift);
  348. }
  349.  
  350. static obj_t dylan_logand(obj_t x, obj_t y)
  351. {
  352.     return make_fixnum(fixnum_value(x) & fixnum_value(y));
  353. }
  354.  
  355. static obj_t dylan_logbitp(obj_t x, obj_t index)
  356. {
  357.     if (fixnum_value(x) & (1 << fixnum_value(index)))
  358.     return obj_True;
  359.     else
  360.     return obj_False;
  361. }
  362.  
  363. static obj_t dylan_logior(obj_t x, obj_t y)
  364. {
  365.     return make_fixnum(fixnum_value(x) | fixnum_value(y));
  366. }
  367.  
  368. static obj_t dylan_lognot(obj_t x)
  369. {
  370.     return make_fixnum(~fixnum_value(x));
  371. }
  372.  
  373. static obj_t dylan_logxor(obj_t x, obj_t y)
  374. {
  375.     return make_fixnum(fixnum_value(x) ^ fixnum_value(y));
  376. }
  377.  
  378. static obj_t dylan_sf_negative(obj_t x)
  379. {
  380.     return make_single(-single_value(x));
  381. }
  382.  
  383. static obj_t dylan_sf_sf_plus(obj_t x, obj_t y)
  384. {
  385.     return make_single(single_value(x) + single_value(y));
  386. }
  387.  
  388. static obj_t dylan_sf_sf_minus(obj_t x, obj_t y)
  389. {
  390.     return make_single(single_value(x) - single_value(y));
  391. }
  392.  
  393. static obj_t dylan_sf_sf_times(obj_t x, obj_t y)
  394. {
  395.     return make_single(single_value(x) * single_value(y));
  396. }
  397.  
  398. static obj_t dylan_sf_sf_divide(obj_t x, obj_t y)
  399. {
  400.     return make_single(single_value(x) / single_value(y));
  401. }
  402.  
  403. static void dylan_sf_sf_trunc(obj_t self, struct thread *thread, obj_t *args)
  404. {
  405.     obj_t *old_sp = args - 1;
  406.     float x = single_value(args[0]);
  407.     int res = x < 0 ? ceil(x) : floor(x);
  408.  
  409.     thread->sp = old_sp + 2;
  410.  
  411.     old_sp[0] = make_fixnum(res);
  412.     old_sp[1] = make_single(x - res);
  413.  
  414.     do_return(thread, old_sp, old_sp);
  415. }
  416.  
  417. static void dylan_sf_sf_floor(obj_t self, struct thread *thread, obj_t *args)
  418. {
  419.     obj_t *old_sp = args - 1;
  420.     float x = single_value(args[0]);
  421.     int res = floor(x);
  422.  
  423.     thread->sp = old_sp + 2;
  424.  
  425.     old_sp[0] = make_fixnum(res);
  426.     old_sp[1] = make_single(x - res);
  427.  
  428.     do_return(thread, old_sp, old_sp);
  429. }
  430.  
  431. static void dylan_sf_sf_ceil(obj_t self, struct thread *thread, obj_t *args)
  432. {
  433.     obj_t *old_sp = args - 1;
  434.     float x = single_value(args[0]);
  435.     int res = ceil(x);
  436.  
  437.     thread->sp = old_sp + 2;
  438.  
  439.     old_sp[0] = make_fixnum(res);
  440.     old_sp[1] = make_single(x - res);
  441.  
  442.     do_return(thread, old_sp, old_sp);
  443. }
  444.  
  445. static void dylan_sf_sf_round(obj_t self, struct thread *thread, obj_t *args)
  446. {
  447.     obj_t *old_sp = args - 1;
  448.     float x = single_value(args[0]);
  449. #ifdef hpux
  450.     /* There is apparently no rint on the hps. */
  451.     int res = floor(x+0.5);
  452. #else
  453.     int res = rint(x);
  454. #endif
  455.  
  456.     thread->sp = old_sp + 2;
  457.  
  458.     old_sp[0] = make_fixnum(res);
  459.     old_sp[1] = make_single(x - res);
  460.  
  461.     do_return(thread, old_sp, old_sp);
  462. }
  463.  
  464. static obj_t dylan_sf_sf_less(obj_t x, obj_t y)
  465. {
  466.     if (single_value(x) < single_value(y))
  467.     return obj_True;
  468.     else
  469.     return obj_False;
  470. }
  471.  
  472. static obj_t dylan_sf_sf_less_or_eql(obj_t x, obj_t y)
  473. {
  474.     if (single_value(x) <= single_value(y))
  475.     return obj_True;
  476.     else
  477.     return obj_False;
  478. }
  479.  
  480. static obj_t dylan_sf_sf_equal(obj_t x, obj_t y)
  481. {
  482.     if (single_value(x) == single_value(y))
  483.     return obj_True;
  484.     else
  485.     return obj_False;
  486. }
  487.  
  488. static obj_t dylan_sf_sf_not_equal(obj_t x, obj_t y)
  489. {
  490.     if (single_value(x) != single_value(y))
  491.     return obj_True;
  492.     else
  493.     return obj_False;
  494. }
  495.  
  496. static obj_t dylan_df_negative(obj_t x)
  497. {
  498.     return make_double(-double_value(x));
  499. }
  500.  
  501. static obj_t dylan_df_df_plus(obj_t x, obj_t y)
  502. {
  503.     return make_double(double_value(x) + double_value(y));
  504. }
  505.  
  506. static obj_t dylan_df_df_minus(obj_t x, obj_t y)
  507. {
  508.     return make_double(double_value(x) - double_value(y));
  509. }
  510.  
  511. static obj_t dylan_df_df_times(obj_t x, obj_t y)
  512. {
  513.     return make_double(double_value(x) * double_value(y));
  514. }
  515.  
  516. static obj_t dylan_df_df_divide(obj_t x, obj_t y)
  517. {
  518.     return make_double(double_value(x) / double_value(y));
  519. }
  520.  
  521. static void dylan_df_df_trunc(obj_t self, struct thread *thread, obj_t *args)
  522. {
  523.     obj_t *old_sp = args - 1;
  524.     double x = double_value(args[0]);
  525.     int res = x < 0 ? ceil(x) : floor(x);
  526.  
  527.     thread->sp = old_sp + 2;
  528.  
  529.     old_sp[0] = make_fixnum(res);
  530.     old_sp[1] = make_double(x - res);
  531.  
  532.     do_return(thread, old_sp, old_sp);
  533. }
  534.  
  535. static void dylan_df_df_floor(obj_t self, struct thread *thread, obj_t *args)
  536. {
  537.     obj_t *old_sp = args - 1;
  538.     double x = double_value(args[0]);
  539.     int res = floor(x);
  540.  
  541.     thread->sp = old_sp + 2;
  542.  
  543.     old_sp[0] = make_fixnum(res);
  544.     old_sp[1] = make_double(x - res);
  545.  
  546.     do_return(thread, old_sp, old_sp);
  547. }
  548.  
  549. static void dylan_df_df_ceil(obj_t self, struct thread *thread, obj_t *args)
  550. {
  551.     obj_t *old_sp = args - 1;
  552.     double x = double_value(args[0]);
  553.     int res = ceil(x);
  554.  
  555.     thread->sp = old_sp + 2;
  556.  
  557.     old_sp[0] = make_fixnum(res);
  558.     old_sp[1] = make_double(x - res);
  559.  
  560.     do_return(thread, old_sp, old_sp);
  561. }
  562.  
  563. static void dylan_df_df_round(obj_t self, struct thread *thread, obj_t *args)
  564. {
  565.     obj_t *old_sp = args - 1;
  566.     double x = double_value(args[0]);
  567. #ifdef hpux
  568.     /* There is apparently no rint on the hps. */
  569.     int res = floor(x+0.5);
  570. #else
  571.     int res = rint(x);
  572. #endif
  573.  
  574.     thread->sp = old_sp + 2;
  575.  
  576.     old_sp[0] = make_fixnum(res);
  577.     old_sp[1] = make_double(x - res);
  578.  
  579.     do_return(thread, old_sp, old_sp);
  580. }
  581.  
  582. static obj_t dylan_df_df_less(obj_t x, obj_t y)
  583. {
  584.     if (double_value(x) < double_value(y))
  585.     return obj_True;
  586.     else
  587.     return obj_False;
  588. }
  589.  
  590. static obj_t dylan_df_df_less_or_eql(obj_t x, obj_t y)
  591. {
  592.     if (double_value(x) <= double_value(y))
  593.     return obj_True;
  594.     else
  595.     return obj_False;
  596. }
  597.  
  598. static obj_t dylan_df_df_equal(obj_t x, obj_t y)
  599. {
  600.     if (double_value(x) == double_value(y))
  601.     return obj_True;
  602.     else
  603.     return obj_False;
  604. }
  605.  
  606. static obj_t dylan_df_df_not_equal(obj_t x, obj_t y)
  607. {
  608.     if (double_value(x) != double_value(y))
  609.     return obj_True;
  610.     else
  611.     return obj_False;
  612. }
  613.  
  614.  
  615. static obj_t dylan_xf_negative(obj_t x)
  616. {
  617.     return make_extended(-extended_value(x));
  618. }
  619.  
  620. static obj_t dylan_xf_xf_plus(obj_t x, obj_t y)
  621. {
  622.     return make_extended(extended_value(x) + extended_value(y));
  623. }
  624.  
  625. static obj_t dylan_xf_xf_minus(obj_t x, obj_t y)
  626. {
  627.     return make_extended(extended_value(x) - extended_value(y));
  628. }
  629.  
  630. static obj_t dylan_xf_xf_times(obj_t x, obj_t y)
  631. {
  632.     return make_extended(extended_value(x) * extended_value(y));
  633. }
  634.  
  635. static obj_t dylan_xf_xf_divide(obj_t x, obj_t y)
  636. {
  637.     return make_extended(extended_value(x) / extended_value(y));
  638. }
  639.  
  640. static obj_t dylan_xf_xf_less(obj_t x, obj_t y)
  641. {
  642.     if (extended_value(x) < extended_value(y))
  643.     return obj_True;
  644.     else
  645.     return obj_False;
  646. }
  647.  
  648. static obj_t dylan_xf_xf_less_or_eql(obj_t x, obj_t y)
  649. {
  650.     if (extended_value(x) <= extended_value(y))
  651.     return obj_True;
  652.     else
  653.     return obj_False;
  654. }
  655.  
  656. static obj_t dylan_xf_xf_equal(obj_t x, obj_t y)
  657. {
  658.     if (extended_value(x) == extended_value(y))
  659.     return obj_True;
  660.     else
  661.     return obj_False;
  662. }
  663.  
  664. static obj_t dylan_xf_xf_not_equal(obj_t x, obj_t y)
  665. {
  666.     if (extended_value(x) != extended_value(y))
  667.     return obj_True;
  668.     else
  669.     return obj_False;
  670. }
  671.  
  672.  
  673. static obj_t dylan_as_identity(obj_t class, obj_t thing)
  674. {
  675.     return thing;
  676. }
  677.  
  678. static obj_t dylan_int_as_sf(obj_t class, obj_t x)
  679. {
  680.     return make_single((float)fixnum_value(x));
  681. }
  682.  
  683. static obj_t dylan_int_as_df(obj_t class, obj_t x)
  684. {
  685.     return make_double((double)fixnum_value(x));
  686. }
  687.  
  688. static obj_t dylan_int_as_xf(obj_t class, obj_t x)
  689. {
  690.     return make_extended((long double)fixnum_value(x));
  691. }
  692.  
  693. static obj_t dylan_sf_as_df(obj_t class, obj_t x)
  694. {
  695.     return make_double((double)single_value(x));
  696. }
  697.  
  698. static obj_t dylan_sf_as_xf(obj_t class, obj_t x)
  699. {
  700.     return make_extended((long double)single_value(x));
  701. }
  702.  
  703. static obj_t dylan_df_as_sf(obj_t class, obj_t x)
  704. {
  705.     return make_single((float)double_value(x));
  706. }
  707.  
  708. static obj_t dylan_df_as_xf(obj_t class, obj_t x)
  709. {
  710.     return make_extended((long double)double_value(x));
  711. }
  712.  
  713. static obj_t dylan_xf_as_sf(obj_t class, obj_t x)
  714. {
  715.     return make_single((float)extended_value(x));
  716. }
  717.  
  718. static obj_t dylan_xf_as_df(obj_t class, obj_t x)
  719. {
  720.     return make_double((double)extended_value(x));
  721. }
  722.  
  723.  
  724.  
  725. /* GC stuff. */
  726.  
  727. static int scav_sf(struct object *ptr)
  728. {
  729.     return sizeof(struct single_float);
  730. }
  731.  
  732. static obj_t trans_sf(obj_t sf)
  733. {
  734.     return transport(sf, sizeof(struct single_float));
  735. }
  736.  
  737. static int scav_df(struct object *ptr)
  738. {
  739.     return sizeof(struct double_float);
  740. }
  741.  
  742. static obj_t trans_df(obj_t sf)
  743. {
  744.     return transport(sf, sizeof(struct double_float));
  745. }
  746.  
  747. static int scav_xf(struct object *ptr)
  748. {
  749.     return sizeof(struct extended_float);
  750. }
  751.  
  752. static obj_t trans_xf(obj_t sf)
  753. {
  754.     return transport(sf, sizeof(struct extended_float));
  755. }
  756.  
  757. void scavenge_num_roots(void)
  758. {
  759.     scavenge(&obj_NumberClass);
  760.     scavenge(&obj_ComplexClass);
  761.     scavenge(&obj_RealClass);
  762.     scavenge(&obj_RationalClass);
  763.     scavenge(&obj_IntegerClass);
  764.     scavenge(&obj_FloatClass);
  765.     scavenge(&obj_SingleFloatClass);
  766.     scavenge(&obj_DoubleFloatClass);
  767.     scavenge(&obj_ExtendedFloatClass);
  768. }
  769.  
  770.  
  771. /* Init stuff. */
  772.  
  773. void make_num_classes(void)
  774. {
  775.     obj_NumberClass = make_abstract_class(FALSE);
  776.     obj_ComplexClass = make_abstract_class(TRUE);
  777.     obj_RealClass = make_abstract_class(TRUE);
  778.     obj_RationalClass = make_abstract_class(TRUE);
  779.     /* <integer> isn't really abstract, but there arn't heap instances */
  780.     /* of it either. */
  781.     obj_IntegerClass = make_abstract_class(TRUE);
  782.     obj_FloatClass = make_abstract_class(TRUE);
  783.     obj_SingleFloatClass = make_builtin_class(scav_sf, trans_sf);
  784.     obj_DoubleFloatClass = make_builtin_class(scav_df, trans_df);
  785.     obj_ExtendedFloatClass = make_builtin_class(scav_xf, trans_xf);
  786. }
  787.  
  788. void init_num_classes(void)
  789. {
  790.     init_builtin_class(obj_NumberClass, "<number>", obj_ObjectClass, NULL);
  791.     init_builtin_class(obj_ComplexClass, "<complex>", obj_NumberClass, NULL);
  792.     init_builtin_class(obj_RealClass, "<real>", obj_ComplexClass, NULL);
  793.     init_builtin_class(obj_RationalClass, "<rational>", obj_RealClass, NULL);
  794.     init_builtin_class(obj_IntegerClass, "<integer>",obj_RationalClass, NULL);
  795.     def_printer(obj_IntegerClass, print_fixnum);
  796.     init_builtin_class(obj_FloatClass, "<float>", obj_RealClass, NULL);
  797.     init_builtin_class(obj_SingleFloatClass, "<single-float>",
  798.                obj_FloatClass, NULL);
  799.     def_printer(obj_SingleFloatClass, print_sf);
  800.     init_builtin_class(obj_DoubleFloatClass, "<double-float>",
  801.                obj_FloatClass, NULL);
  802.     def_printer(obj_DoubleFloatClass, print_df);
  803.     init_builtin_class(obj_ExtendedFloatClass, "<extended-float>",
  804.                obj_FloatClass, NULL);
  805.     def_printer(obj_ExtendedFloatClass, print_xf);
  806. }
  807.  
  808. void init_num_functions(void)
  809. {
  810.     obj_t sf = list1(obj_SingleFloatClass);
  811.     obj_t df = list1(obj_DoubleFloatClass);
  812.     obj_t two_objs = list2(obj_ObjectClass, obj_ObjectClass);
  813.     obj_t two_ints = list2(obj_IntegerClass, obj_IntegerClass);
  814.     obj_t two_sfs = list2(obj_SingleFloatClass, obj_SingleFloatClass);
  815.     obj_t two_dfs = list2(obj_DoubleFloatClass, obj_DoubleFloatClass);
  816.     obj_t two_xfs = list2(obj_ExtendedFloatClass, obj_ExtendedFloatClass);
  817.     obj_t int_and_real = list2(obj_IntegerClass, obj_RealClass);
  818.     obj_t int_and_sf = list2(obj_IntegerClass, obj_SingleFloatClass);
  819.     obj_t int_and_df = list2(obj_IntegerClass, obj_DoubleFloatClass);
  820.     obj_t int_sing = singleton(obj_IntegerClass);
  821.     obj_t float_sing = singleton(obj_FloatClass);
  822.     obj_t sf_sing = singleton(obj_SingleFloatClass);
  823.     obj_t df_sing = singleton(obj_DoubleFloatClass);
  824.     obj_t xf_sing = singleton(obj_ExtendedFloatClass);
  825.  
  826.     define_function("==", two_objs, FALSE, obj_False, FALSE, obj_BooleanClass,
  827.             dylan_idp);
  828.     define_method("=", two_objs, FALSE, obj_False, FALSE, obj_BooleanClass,
  829.           dylan_idp);
  830.  
  831.     define_generic_function("truncate/", 2, FALSE, obj_False, FALSE,
  832.                 int_and_real, obj_False);
  833.     define_generic_function("truncate", 1, FALSE, obj_False, FALSE,
  834.                 int_and_real, obj_False);
  835.     define_generic_function("floor/", 2, FALSE, obj_False, FALSE,
  836.                 int_and_real, obj_False);
  837.     define_generic_function("floor", 1, FALSE, obj_False, FALSE,
  838.                 int_and_real, obj_False);
  839.     define_generic_function("ceiling/", 2, FALSE, obj_False, FALSE,
  840.                 int_and_real, obj_False);
  841.     define_generic_function("ceiling", 1, FALSE, obj_False, FALSE,
  842.                 int_and_real, obj_False);
  843.     define_generic_function("round/", 2, FALSE, obj_False, FALSE,
  844.                 int_and_real, obj_False);
  845.     define_generic_function("round", 1, FALSE, obj_False, FALSE,
  846.                 int_and_real, obj_False);
  847.  
  848.     define_method("negative", list1(obj_IntegerClass), FALSE, obj_False, FALSE,
  849.           obj_IntegerClass, dylan_int_negative);
  850.     define_method("+", two_ints, FALSE, obj_False, FALSE, obj_IntegerClass,
  851.           dylan_int_int_plus);
  852.     define_method("-", two_ints, FALSE, obj_False, FALSE, obj_IntegerClass,
  853.           dylan_int_int_minus);
  854.     define_method("*", two_ints, FALSE, obj_False, FALSE, obj_IntegerClass,
  855.           dylan_int_int_times);
  856.     add_method(find_variable(module_BuiltinStuff, symbol("truncate/"),
  857.                  FALSE, FALSE)->value,
  858.            make_raw_method("truncate/", two_ints, FALSE, obj_False, FALSE,
  859.                    two_ints, obj_False, dylan_int_int_trunc));
  860.     add_method(find_variable(module_BuiltinStuff, symbol("floor/"),
  861.                  FALSE, FALSE)->value,
  862.            make_raw_method("floor/", two_ints, FALSE, obj_False, FALSE,
  863.                    two_ints, obj_False, dylan_int_int_floor));
  864.     add_method(find_variable(module_BuiltinStuff, symbol("ceiling/"),
  865.                  FALSE, FALSE)->value,
  866.            make_raw_method("ceiling/", two_ints, FALSE, obj_False, FALSE,
  867.                    two_ints, obj_False, dylan_int_int_ceil));
  868.     add_method(find_variable(module_BuiltinStuff, symbol("round/"),
  869.                  FALSE, FALSE)->value,
  870.            make_raw_method("round/", two_ints, FALSE, obj_False, FALSE,
  871.                    two_ints, obj_False, dylan_int_int_round));
  872.     define_method("<", two_ints, FALSE, obj_False, FALSE,
  873.           obj_BooleanClass, dylan_int_int_less);
  874.     define_method("=", two_ints, FALSE, obj_False, FALSE,
  875.           obj_BooleanClass, dylan_int_int_equal);
  876.     define_function("ash", two_ints, FALSE, obj_False, FALSE,
  877.             obj_IntegerClass, dylan_ash);
  878.     define_function("logand", two_ints, FALSE, obj_False, FALSE,
  879.             obj_IntegerClass, dylan_logand);
  880.     define_function("logbit?", two_ints, FALSE, obj_False, FALSE,
  881.             obj_BooleanClass, dylan_logbitp);
  882.     define_function("logior", two_ints, FALSE, obj_False, FALSE,
  883.             obj_IntegerClass, dylan_logior);
  884.     define_function("lognot", list1(obj_IntegerClass), FALSE, obj_False, FALSE,
  885.             obj_IntegerClass, dylan_lognot);
  886.     define_function("logxor", two_ints, FALSE, obj_False, FALSE,
  887.             obj_IntegerClass, dylan_logxor);
  888.  
  889.     define_method("negative", sf, FALSE, obj_False, FALSE,
  890.           obj_SingleFloatClass, dylan_sf_negative);
  891.     define_method("+", two_sfs, FALSE, obj_False, FALSE, obj_SingleFloatClass,
  892.           dylan_sf_sf_plus);
  893.     define_method("-", two_sfs, FALSE, obj_False, FALSE, obj_SingleFloatClass,
  894.           dylan_sf_sf_minus);
  895.     define_method("*", two_sfs, FALSE, obj_False, FALSE, obj_SingleFloatClass,
  896.           dylan_sf_sf_times);
  897.     define_method("/", two_sfs, FALSE, obj_False, FALSE, obj_SingleFloatClass,
  898.           dylan_sf_sf_divide);
  899.     add_method(find_variable(module_BuiltinStuff, symbol("truncate"),
  900.                  FALSE, FALSE)->value,
  901.            make_raw_method("truncate", sf, FALSE, obj_False, FALSE,
  902.                    int_and_sf, obj_False, dylan_sf_sf_trunc));
  903.     add_method(find_variable(module_BuiltinStuff, symbol("floor"),
  904.                  FALSE, FALSE)->value,
  905.            make_raw_method("floor", sf, FALSE, obj_False, FALSE,
  906.                    int_and_sf, obj_False, dylan_sf_sf_floor));
  907.     add_method(find_variable(module_BuiltinStuff, symbol("ceiling"),
  908.                  FALSE, FALSE)->value,
  909.            make_raw_method("ceiling", sf, FALSE, obj_False, FALSE,
  910.                    int_and_sf, obj_False, dylan_sf_sf_ceil));
  911.     add_method(find_variable(module_BuiltinStuff, symbol("round"),
  912.                  FALSE, FALSE)->value,
  913.            make_raw_method("round", sf, FALSE, obj_False, FALSE,
  914.                    int_and_sf, obj_False, dylan_sf_sf_round));
  915.     define_method("<", two_sfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  916.           dylan_sf_sf_less);
  917.     define_method("<=", two_sfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  918.           dylan_sf_sf_less_or_eql);
  919.     define_method("=", two_sfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  920.           dylan_sf_sf_equal);
  921.     define_method("~=", two_sfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  922.           dylan_sf_sf_not_equal);
  923.     
  924.     define_method("negative", df, FALSE, obj_False, FALSE,
  925.           obj_DoubleFloatClass, dylan_df_negative);
  926.     define_method("+", two_dfs, FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  927.           dylan_df_df_plus);
  928.     define_method("-", two_dfs, FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  929.           dylan_df_df_minus);
  930.     define_method("*", two_dfs, FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  931.           dylan_df_df_times);
  932.     define_method("/", two_dfs, FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  933.           dylan_df_df_divide);
  934.     add_method(find_variable(module_BuiltinStuff, symbol("truncate"),
  935.                  FALSE, FALSE)->value,
  936.            make_raw_method("truncate", df, FALSE, obj_False, FALSE,
  937.                    int_and_df, obj_False, dylan_df_df_trunc));
  938.     add_method(find_variable(module_BuiltinStuff, symbol("floor"),
  939.                  FALSE, FALSE)->value,
  940.            make_raw_method("floor", df, FALSE, obj_False, FALSE,
  941.                    int_and_df, obj_False, dylan_df_df_floor));
  942.     add_method(find_variable(module_BuiltinStuff, symbol("ceiling"),
  943.                  FALSE, FALSE)->value,
  944.            make_raw_method("ceiling", df, FALSE, obj_False, FALSE,
  945.                    int_and_df, obj_False, dylan_df_df_ceil));
  946.     add_method(find_variable(module_BuiltinStuff, symbol("round"),
  947.                  FALSE, FALSE)->value,
  948.            make_raw_method("round", df, FALSE, obj_False, FALSE,
  949.                    int_and_df, obj_False, dylan_df_df_round));
  950.     define_method("<", two_dfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  951.           dylan_df_df_less);
  952.     define_method("<=", two_dfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  953.           dylan_df_df_less_or_eql);
  954.     define_method("=", two_dfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  955.           dylan_df_df_equal);
  956.     define_method("~=", two_dfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  957.           dylan_df_df_not_equal);
  958.  
  959.     define_method("negative", list1(obj_ExtendedFloatClass), FALSE, obj_False,
  960.           FALSE, obj_ExtendedFloatClass, dylan_xf_negative);
  961.     define_method("+", two_xfs, FALSE, obj_False, FALSE,
  962.           obj_ExtendedFloatClass, dylan_xf_xf_plus);
  963.     define_method("-", two_xfs, FALSE, obj_False, FALSE,
  964.           obj_ExtendedFloatClass, dylan_xf_xf_minus);
  965.     define_method("*", two_xfs, FALSE, obj_False, FALSE,
  966.           obj_ExtendedFloatClass, dylan_xf_xf_times);
  967.     define_method("/", two_xfs, FALSE, obj_False, FALSE,
  968.           obj_ExtendedFloatClass, dylan_xf_xf_divide);
  969.     define_method("<", two_xfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  970.           dylan_xf_xf_less);
  971.     define_method("<=", two_xfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  972.           dylan_xf_xf_less_or_eql);
  973.     define_method("=", two_xfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  974.           dylan_xf_xf_equal);
  975.     define_method("~=", two_xfs, FALSE, obj_False, FALSE, obj_BooleanClass,
  976.           dylan_xf_xf_not_equal);
  977.     
  978.     define_method("as", list2(int_sing, obj_IntegerClass),
  979.           FALSE, obj_False, FALSE, obj_IntegerClass,
  980.           dylan_as_identity);
  981.     define_method("as", list2(float_sing, obj_IntegerClass),
  982.           FALSE, obj_False, FALSE, obj_SingleFloatClass,
  983.           dylan_int_as_sf);
  984.     define_method("as", list2(sf_sing, obj_IntegerClass),
  985.           FALSE, obj_False, FALSE, obj_SingleFloatClass,
  986.           dylan_int_as_sf);
  987.     define_method("as", list2(df_sing, obj_IntegerClass),
  988.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  989.           dylan_int_as_df);
  990.     define_method("as", list2(xf_sing, obj_IntegerClass),
  991.           FALSE, obj_False, FALSE, obj_ExtendedFloatClass,
  992.           dylan_int_as_xf);
  993.  
  994.     define_method("as", list2(float_sing, obj_FloatClass),
  995.           FALSE, obj_False, FALSE, obj_FloatClass,
  996.           dylan_as_identity);
  997.  
  998.     define_method("as", list2(sf_sing, obj_SingleFloatClass),
  999.           FALSE, obj_False, FALSE, obj_SingleFloatClass,
  1000.           dylan_as_identity);
  1001.     define_method("as", list2(df_sing, obj_SingleFloatClass),
  1002.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1003.           dylan_sf_as_df);
  1004.     define_method("as", list2(xf_sing, obj_SingleFloatClass),
  1005.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1006.           dylan_sf_as_xf);
  1007.  
  1008.     define_method("as", list2(sf_sing, obj_DoubleFloatClass),
  1009.           FALSE, obj_False, FALSE, obj_SingleFloatClass,
  1010.           dylan_df_as_sf);
  1011.     define_method("as", list2(df_sing, obj_DoubleFloatClass),
  1012.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1013.           dylan_as_identity);
  1014.     define_method("as", list2(xf_sing, obj_DoubleFloatClass),
  1015.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1016.           dylan_df_as_xf);
  1017.  
  1018.     define_method("as", list2(sf_sing, obj_ExtendedFloatClass),
  1019.           FALSE, obj_False, FALSE, obj_SingleFloatClass,
  1020.           dylan_xf_as_sf);
  1021.     define_method("as", list2(df_sing, obj_ExtendedFloatClass),
  1022.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1023.           dylan_xf_as_df);
  1024.     define_method("as", list2(xf_sing, obj_ExtendedFloatClass),
  1025.           FALSE, obj_False, FALSE, obj_DoubleFloatClass,
  1026.           dylan_as_identity);
  1027. }
  1028.